Fifty: Elektronik/FIFTY Elektronik (PS_Computer_Vertrieb).iso/ps8/fty1017/gepackt.exe/DISK2/PLOTSRC.EXE/PLGLOB.INC

Text File | 1993-11-10 | 30.5 KB | 1,181 lines

Procedure InitColors;
begin
  If Not(MODECO80) then
  begin
    ModeWinCol:=CalcAttr(Crt.white,Crt.black);
    ModeLowCol:=CalcAttr(Crt.White,Crt.black);
    ModeNorCol:=CalcAttr(Crt.lightgray,Crt.black);
    ModeFlpCol:=CalcAttr(Crt.black,Crt.lightgray);
    ModeHiCol :=CalcAttr(Crt.White,Crt.black);
    ModeHeadCol:=ModeLowCol;
    MainWinCol:=ModeWinCol;
    MainHeadCol:=ModeWinCol;
    MainNorCol:=ModeNorCol;
    MainLowCol:=ModeLowCol;
    MainHiCol:=CalcAttr(Crt.White,Crt.black);
    MainFlpCol:=ModeFlpCol;
    BordCol:=ModeWinCol;
    CopyWrCol:=ModeLowCol;
    TitelCol:=ModeWinCol;
    DiaWinCol:=Calcattr(Crt.black,Crt.LightGray);
    DiaHeadCol:=DiaWinCol;
  end;
end;

PROCEDURE Border;
  Var Soben,Sunten,Strenn,Srand:Str80;
      I :Integer;
  BEGIN  (*   Border  *)
    clrscr;
    Soben :='╔'+ConstStr('═',78)+'╗';
    Srand :='║'+ConstStr(' ',78)+'║';
    Sunten:='╚'+ConstStr('═',78)+'╝';
    Strenn:='╠'+ConstStr('═',78)+'╣';
    DisplayString(1,01,BordCol,Soben);
    For I:=2 to 5 Do DisplayString(1,I,BordCol,Srand);
    DisplayString(1,06,BordCol,Strenn);
    For I:=7 to 23 Do DisplayString(1,I,BordCol,Srand);
    DisplayString(1,24,BordCol,Sunten);
    If HelpAvailable then
      DisplayString(20,24,ModeLowCol,Center(' Hilfe : ALT-H oder SHIFT-ALT ',40));
    DisplayString(4,3,TitelCol,Center(titel,74));
    DisplayString(4,4,TitelCol,Center(titel2,74));
    DisplayString(4,5,TitelCol,Center('V'+Version,74));
    DisplayString(4,6,CopyWrCol,' '+copyright+' ');
    DisplayString(70,6,CopyWrCol,' '+SetupInfo.Sernumber+' ');
    ShowWindow(Men_Main.Picture);
  END;  (*  Border  *)

Procedure Abbrechen;
Var TC :Char;
Begin
  If Keypressed Then
    Begin
      If SelectError('Abbrechen ? J/N','',[Esc,'J','N'])='J' then
        Weiter:=False
    End;
End;

Procedure OpenPrOut(Y :Integer;Var TC :Char);
Var OutFname: Str64;
    Makeit,FnameOk :Boolean;
    S:Str80;
    N,E :Str15;
begin
  NoError:=true;
  DevMode:=false;
  If OutPath=''then
      OutPath:=ActivePath;
  If Aufdatei then
    begin
      GotoXY(3,Y);Write('Ausgabe der Plot-Daten auf eine Datei');
      GotoXY(3,Y+1);Write('Dateiname :');
      OutFname:=HauptF+'.PLT';
      ProcessFileName(Outpath,OutFname);
      Repeat
        Repeat
          InputKbd(OutFname,50,16,Y+1,[^M,^Q,^Z,Esc],Alphas+DOSseparators,TC);
          S:=OutFName;
          S:=UpcaseStr(S);
          FnameOK:=Pos(Dsuf,S)=0;
          If Not(FnameOk) Then
          begin
            Beep;
            GotoXY(3,Y+3);ClrEol;Write('Unzulässiger Dateiname');
          end;
        Until FnameOk Or (TC=Esc);
        GotoXY(3,Y+3);ClrEol;
        If TC<>Esc Then
        begin
          {$I-}
          Assign(PrOutFile,OutFName);
      Repeat
            Reset(PrOutFile);
        IOstatus:=IoResult;
        Ok:=IoStatus=0;
      Until Not(OpenError);
          Makeit:=true;
          If Ok Then
            begin
              Close(PrOutFile);
              If SelectError('Datei vorhanden,überschreiben ? J/N',
                             'Warnung:',['J','N',Esc])='J' then Makeit:=true
              else begin TC:=Esc; Makeit:=false; end;
           end;
         If Makeit Then
         begin
           Assign(PrOutFile,OutFName);
       Repeat
            Rewrite(PrOutFile);
        IOstatus:=IoResult;
        Ok:=IoStatus=0;
           Until Not(OpenError);
           If Not(Ok) Then
           begin
             TC:=SelectError('Datei kann nicht erzeugt werden  - <Esc>',
                            'Fehler:',[Esc]);
           end else
            begin
             SetDeviceBinary(PrOutFile);
             Fsplit(OutFname,OutPath,N,E);
             NormFname(OutPath);
            end;
         end;
        {$I+}
        end;
      Until  Ok or (TC=Esc);
     If Not(Ok and (TC<>Esc)) then TC:=Esc;
     end
     else
      begin
    With SetupInfo.PinstInfo Do
    begin
          DevMode:=OutDevice<>'';
          AufDatei:=DevMode;
          {$I-}
          If DevMode then
           Assign(PrOutFile,OutDevice)
          else
           begin
             If Serial Then
             begin
                CTS_Handshake:=Xonoff=2;
                DSR_Handshake:=Xonoff=1;
                XonXoff:=(xonoff<>1) and (xonoff<>2);
            AssignAUX(PrOutFile,SerPortNr,Baudrate,
                    Stopbits,Databits,Parity)

             end
         else
            AssignLST(PrOutFile,PlotterNr);
           end;
          Rewrite(PrOutFile);
          Noerror:=Ioresult=0;
          {$I+}
          SetDeviceBinary(PrOutFile);
          TC:=#0;
          If OutDevice<>'' then
           begin
            GotoXY(3,Y+1);Write('Dateiname :',OutDevice);
           end;
        End;
      end;
end;

Procedure ClosePrOut;
begin
  If AufDatei Then
   If NoError Then
     begin {$I-}
       Write(PrOutFile,^Z);{ EOF-Markierung }
       NoError:=IOresult=0;
     end;
  Close(PrOutFile);
  If AufDatei Then
    begin
      If DevMode then Aufdatei:=false;
      Noerror:=NoError And (Ioresult=0);
      If Not(NoError) then
      begin
        TC:=SelectError('Fehler beim Schreiben der Datei  - <Esc>','',[Esc]);
      end;
   end;
   {$I+}
end;

Function DateStr(Var TimeDate:DateRec):Str40;
Var Sy,Sd,Sm:Str15;
begin
  With TimeDate Do
  begin
    Str(Year,Sy);
    Str(Month,Sm);
    Str(Day,Sd);
    DateStr:=Sd+'.'+Sm+'.'+Sy;
  end;
end;

Function TimeStr(Var TimeDate:DateRec):Str40;
Var Sh,Sm:Str15;
begin
  With TimeDate Do
  begin
    Str(Hour,Sh);
    Str(Minutes,Sm);
    Sm:='00'+Sm;
    While Length(Sm)>2 do Delete(Sm,1,1);
    TimeStr:=Sh+':'+Sm;
  end;
end;

Function VersionStr(V:Integer):Str40;
Var S :Str40;
begin
  RealStr(V/10.0,6,S);
  VersionStr:=S;
end;

Function ArbeitsZeitStr(T :Longint):Str40;
Var H,M :Longint;
    Sm,Sh :Str15;
begin
  T:=T div 60; { Minuten }
  H:= T div 60;
  M:= T mod 60;
  Str(H,Sh);
  Str(M,Sm);
  Sm:='00'+Sm;
  While Length(Sm)>2 do Delete(Sm,1,1);
  ArbeitsZeitStr:=Sh+' h: '+Sm+' min';
end;

Procedure Mirror(Var Px,Py :integer; Spiegel :Spiegelpar);
Var P1,P2 :Real;
begin
  P1:=Px;
  P2:=Py;
  With Spiegel Do
  begin
    Px:=RealtoInt(A11*P1+A12*P2+Ex);
    Py:=RealtoInt(A21*P1+A22*P2+Ey);
  end;
end;

Procedure Spiegle_Obj(Var Objekt :Bildelement;Var Spiegel :Spiegelpar);

Var Ax,Ay,Temp,Phi_Korr :Integer;

Begin
  With Objekt Do
  Begin
    Case ElementTyp of
      Kreis,
      M_arc    :  begin
                    Temp:=Segmentalpha;
                    Segmentalpha:=-Segmentbeta;
                    Segmentbeta:=-temp;
                  end;
      Rechteck :begin
                  Ax:=0;
                  Ay:=Rbreite;
                  Turnto(Orient);
                  Rotate(Ax,Ay);
                  Inc(Aufhaenger.X,Ax);
                  Inc(Aufhaenger.Y,Ay);
                end;

      Linie,
      M_line   :Mirror(Endpunkt.X,Endpunkt.Y,Spiegel);
      Schrift,
      M_text   :begin
                  If Spiegel.MirrText then
                    begin
                      Phi_Korr:=180;
                      Art:=Art xor 2 { Spiegel-Bit umkehren}
                    end
                  else
                    begin
                      Ay:=0;
                      Ax:=0;
                      Phi_Korr:=0;
                      With Spiegel Do
                      If (PhiAxis>=315) or (PhiAxis<=45) Then
                        Ay:=RealtoInt(Hoehe)
                       else
                       begin
                        Ax:=TextLaenge(Objekt);
                        Phi_Korr:=180;
                       end;
                      Turnto(Orient);
                      Rotate(Ax,Ay);
                      Inc(Aufhaenger.X,Ax);
                      Inc(Aufhaenger.Y,Ay);
                    end;
                    Dec(Orient,Phi_Korr);
                 end;
      MassPfeil: begin
                   Ax:=RealtoInt(Msize*Masslaenge);
                   Ay:=0;
                   Turnto(Orient);
                   Rotate(Ax,Ay);
                   Inc(Aufhaenger.X,Ax);
                   Inc(Aufhaenger.Y,Ay);
                   Dec(Orient,180);
                  end;
      Macro    : begin Faktor:=-Faktor; Dec(Orient,180); end;
    End;
    Mirror(Aufhaenger.X,Aufhaenger.Y,Spiegel);
    If Elementtyp<>Auge Then Orient:=Spiegel.PhiAxis*2-Orient;
    Normalize(Orient);
  End;
End;


Procedure Zeichne(Objekt :Bildelement;MacWert :Macparms);
Var Phi           :Integer;
    X0,Y0,Mass1,
    Mass2,Groesse :Real;
    Color  :GrColor;
 Function  PlStretch(X:Integer;Scale :Real) :Real;
 Begin
   With SetupInfo.Voreinstellung Do
   PlStretch:=Scale*PlotScale*Einheit*X;
 End;
 Function SetLbreite(B:Integer):Real;
 begin
   If B=0 then
      SetLbreite:=0
     else
      SetLbreite:=PlStretch(B,Groesse)+LoetstopPlus;
 end;

 Procedure Transform(Var X,Y :Real);
 Var Xp,Yp :real;
 Begin
  With MacWert Do
  If TMac Then
  Begin
    Turnto(Phi);
    Xp:=Mfac*X;              Yp:=Mfac*Y;
    Rotreal(Xp,Yp);
    X:=Xp+Xmac;Y:=Yp+Ymac;
  End;
  With SetupInfo.Voreinstellung Do
  Begin
    X:=(X-Ursprung.X)*PlotScale*Einheit;
    Y:=(Y-Ursprung.Y)*PlotScale*Einheit;
  End;
    X:=X+PlotOffset.X;
    Y:=Y+PlotOffset.Y;
 End;
 Procedure PaintAuge;
 var Mass3 :Real;
 Begin
  With Objekt Do
   Begin
     If ElementTyp=Quadrat then Exchange(AussenD,InnenD);
     Mass1:=PlotLimit(PlStretch(AussenD,Groesse)-Stiftbreite);
     Mass2:=PlStretch(InnenD,Groesse);
     If ElementTyp=Oval then
        Mass3:=PlStretch(Oval_len,Groesse)-Stiftbreite
       else
        Mass3:=0;
     If  PlotModus=LoetStop then
       begin
         Mass1:=Mass1+Loetstopplus;
         Mass2:=0;
         Mass3:=Mass3+Loetstopplus;
       End;
     Transform(X0,Y0);
     If ElementTyp<>Auge then Turnto(Orient+Phi)
      else Turnto(0);
     Case Elementtyp of
       Auge:   Eye(X0,Y0,Mass1,Mass2,Color);
       Quadrat:SqareEye(X0,Y0,Mass1,Mass2,Color);
       Oval   :OvalEye(X0,Y0,Mass1,Mass2,Mass3,Color);
       Achteck:Octagon(X0,Y0,Mass1,Mass2,Color);
     end;
   End;
 End;
 Procedure PaintKreis;
 Var Decr : Real;
     LB   :Real;
     Min1,Min2  :Real;
     Direction,Ende,Einmal:Boolean;
     Cx,Cy,Rx,Ry :real;
     Procedure ArcKoord(rx,ry:Real;Phi :Integer);
     begin
       SinusCosinus(Phi,CY,CX);
       CX:=CX*RX;CY:=CY*Ry;
       RotReal(CX,CY);
       CX:=CX+X0;
       CY:=CY+Y0;
     end;
 Begin
  Direction:=True;
  Decr:=0.75*Stiftbreite;
  If Decr<0.05 then Decr:=0.05;
  With Objekt Do
    Begin
      LB:=Setlbreite(Kbreite)-Stiftbreite;
      Einmal:=LB<=0;
      If Einmal then LB:=0;
      Rx:=PlotLimit(PlStretch(HalbX,Groesse));
      Ry:=PlotLimit(PlStretch(HalbY,Groesse));
      LB:=0.5*LB;
      Min1:=Rx-LB;
      Min2:=Ry-LB;
      Mass1:=Rx+LB;
      Mass2:=Ry+LB;
      If Sectorfill then
      begin
        Min1:=0.1;
        Min2:=0.1;
        Einmal:=false;
      end;
      If PlotModus=TestPlot then
      begin
        If Sectorfill then
          begin
           Decr:=(Mass1+Mass2)*0.1;
           If Decr<2*Stiftbreite then Decr:=2*Stiftbreite;
          end
          else Decr:=2*LB+0.0001;
      end;
      LineType(LTyp);
      Transform(X0,Y0);Turnto(Orient+Phi);
      Repeat
       Ende:=((Mass1<Min1)) or ((Mass2<Min2));
       If Ende then
         begin
           Mass1:=Min1;
           Mass2:=Min2;
         end;
       Circle(X0,Y0,Mass1,Mass2,SegmentAlpha,SegmentBeta,Color,Direction);
       Direction:=Not(direction);
       Mass1:=Mass1-Decr;Mass2:=Mass2-Decr;
      Until Ende or Einmal;
      If (SectorFill or (LB>0.1)) and (Segmentbeta-SegmentAlpha<>360) Then
      begin
        If (Sectorfill) and (PlotModus=TestPlot) then
        begin
          ArcKoord(Rx,Ry,Segmentbeta);
          Pencolor(0);
          Moveto(Cx,Cy);
          Pencolor(Color);
          Moveto(X0,Y0);
          ArcKoord(Rx,Ry,Segmentalpha);
          Pencolor(Color);
          Moveto(Cx,Cy);
        end
        else
          If AdaptLines then
          begin
            ArcKoord(Rx,Ry,SegmentAlpha);
            Eye(CX,Cy,2.0*LB,0,Color);
            ArcKoord(Rx,Ry,SegmentBeta);
            Eye(CX,Cy,2.0*LB,0,Color);
          end
          else If PlotModus=Testplot then
            begin
              ArcKoord(Rx-LB,Ry-LB,SegmentAlpha);
              Pencolor(0); Moveto(CX,Cy);
              ArcKoord(Rx+LB,RY+LB,SegmentAlpha);
              Pencolor(Color); Moveto(CX,Cy);
              ArcKoord(Rx-LB,RY-LB,Segmentbeta);
              Pencolor(0); Moveto(CX,Cy);
              ArcKoord(RX+LB,RY+LB,Segmentbeta);
              Pencolor(Color); Moveto(CX,Cy);
            end;
      end;
      LineType(full);
    End;
  End;
  Procedure Paint4eck;
  Var DL,Bx,By,
     Margin :Real;

  Begin
    With Objekt Do
      Begin
        LineType(LTyp);
        If Rfill Then
         Begin
           If RLaenge>RBreite Then
             Margin:= Rbreite
           Else
             Margin:=RLaenge;
           Margin:=0.5*Margin;
         End
        Else
          Margin:=Rand;
        Transform(X0,Y0);Turnto(Phi+Orient);
        Mass1:=PlotLimit(PlStretch(RLaenge,Groesse));
        Mass2:=PlotLimit(PlStretch(RBreite,Groesse));
        With SetupInfo.Voreinstellung Do
          Margin:=PlotLimit(Groesse*PlotScale*Einheit*Margin);
        If (Rand>0) or Rfill then
          DL:=StiftBreite
        else
          DL:=0;
        If PlotModus=LoetStop then
          begin
            DL:=DL-LoetstopPlus;
            Margin:=Margin+LoetstopPlus;
          end;
        Mass1:=Mass1-Dl;
        If Mass1<0 then Mass1:=0;
        Mass2:=Mass2-Dl;
        If Mass2<0 then Mass2:=0;
        Bx:=DL*0.5;By:=Bx;
        RotReal(Bx,By);
        X0:=Bx+X0;Y0:=By+Y0;
        Rectangle(X0,Y0,Mass1,Mass2,Margin,Color);
        LineType(full);
      End;
  End;
  Procedure PaintLine;
  Var XE,YE,
      B     :Real;
  Begin
    With Objekt Do
      Begin
        LineType(LTyp);
        XE:=Endpunkt.X;YE:=Endpunkt.Y;
        Transform(X0,Y0);
        Transform(XE,YE);
        Pencolor(0);Moveto(X0,Y0);
        If Ltyp<>full Then
        Begin
          Pencolor(Color);Moveto(XE,YE);
          Pencolor(0);
         End
        Else
          begin
            With SetupInfo.Voreinstellung Do
              B:=SetLbreite(Lbreite);
            Linepaint(X0,Y0,XE,YE,B,Color,AdaptLines);
          end;
        Pencolor(0);
        LineType(full);
      End;
  End;
  Procedure PaintText;
  Var H :Real;
      S :Str64;
  Begin
  With Objekt Do
    Begin
      With SetupInfo.Voreinstellung Do
      H:=PlotScale*Einheit*Hoehe*Groesse;
      Transform(X0,Y0);
      Turnto(Phi+Orient);
      If (Length(Wortlaut)>1) and (Wortlaut[1]='#') then
         begin
          Case Upcase(WortLaut[2]) of
           'Z'  : S:=TimeStr(DateInfo.Updated);
           'D'  : S:=DateStr(DateInfo.Updated);
           'V'  : S:=VersionStr(DateInfo.Orient);
           'A'  : S:=ArbeitsZeitStr(DateInfo.WorkingTime);
           'T'  : S:=TimeStr(DateInfo.Created);
           'E'  : S:=DateStr(DateInfo.Created);
           'N'  : S:=Filesetup.DWG+Dsuf;
           'P'  : S:=FileSetup.DWGpath;
           'B'  : S:=FileSetup.Libpath;
           else S:=Wortlaut;
          end;
          Wstring(X0,Y0,S,Color,H,Art);
        end else Wstring(X0,Y0,Wortlaut,Color,H,Art);
    End;
  End;
Procedure PaintPfeil;
Begin
  With Objekt Do
  Begin
    Transform(X0,Y0);
    Turnto(Phi+Orient);
    With SetupInfo.Voreinstellung do
      Pfeil(X0,Y0,Einheit*Masslaenge,Msize*Groesse*PlotScale,Masstext,Color);
  End;
End;

Procedure PaintSpitze;
Begin
  With Objekt  Do
  Begin
    LineType(Ltyp);
    With SetupInfo.Voreinstellung Do
      MP_Hoehe:=PlotScale*Einheit*MP_Hoehe*Groesse;
    Transform(X0,Y0);
    Turnto(Phi+Orient);
    PfeilSpitze(X0,Y0,MP_Hoehe,Color);
  End;
End;

Begin
  With Objekt Do
  Begin
   If Ebene in PlotLayers Then
   Begin
    If Macwert.MirMac then
      Spiegle_Obj(Objekt,Yaxis);
    Groesse:=Macwert.Mfac;
    Phi:=Macwert.MPhi;
    Color:=GrColor(EbenenIndex(Ebene));
    Pencolor(Color);
    X0:=Aufhaenger.X;
    Y0:=Aufhaenger.Y;
    Case ElementTyp of
      Auge,
      Quadrat,
      Oval,
      achteck  :PaintAuge;
      Kreis,
      M_arc    :PaintKreis;
      Rechteck :Paint4eck;
      Linie,
      M_line   :PaintLine;
      Schrift,
      M_text    :PaintText;
      Masspfeil :PaintPfeil;
      M_Peek    :PaintSpitze;
      Macro    :Begin
                  Transform(X0,Y0);
                  Wstring(X0,Y0,Fullname_O(Objekt),Color,2.5,0);
                End;
    End;
   End;
  End;
  Pencolor(0);
End;

Procedure Change(Var Objekt :Bildelement;MacWert :Macparms);
Var Phi      :Integer;
    Groesse  :Real;
 Procedure Transform(Var X,Y :Integer);
 Var Xp,Yp :real;
 Begin
  Turnto(Phi);
  With MacWert Do
  Begin
    Xp:=Mfac*X;
    Yp:=Mfac*Y;
    Rotreal(Xp,Yp);
    X:=RealtoInt(Xp)+Xmac;Y:=RealtoInt(Yp)+Ymac;
  End;
 End;
 Procedure ChangeAuge;
 Begin
  With Objekt Do
   Begin
     If Elementtyp<>Auge then
       Orient:=Orient+Phi;
     If elementTyp=Oval then
       Oval_len:=RealtoInt(Groesse*Oval_Len);
     AussenD:=Minimal(RealtoInt(Groesse*AussenD));
     InnenD:=RealtoInt(Groesse*InnenD);
   End;
 End;
 Procedure ChangeQuad;
 Begin
  With Objekt Do
    Begin
      Qbreite:=Minimal(RealtoInt(Groesse*Qbreite));
      QinnenD:=RealtoInt(Groesse*QinnenD);

    End;
 End;
 Procedure ChangeKreis;
 Begin
  With Objekt Do
    Begin
      Kbreite:=RealtoInt(Groesse*Kbreite);
      HalbX:=Minimal(RealtoInt(Groesse*HalbX));
      HalbY:=Minimal(RealtoInt(Groesse*HalbY));
      Orient:=Orient+Phi;
    End;
  End;
  Procedure Change4eck;
  Begin
    With Objekt Do
      Begin
        Orient:=Phi+Orient;
        Rlaenge:=Minimal(RealtoInt(Groesse*RLaenge));
        Rbreite:=Minimal(RealtoInt(Groesse*RBreite));
        Rand:=RealtoInt(Groesse*Rand);
      End;
  End;
  Procedure ChangeLine;
  Begin
    With Objekt Do
      Begin
        Lbreite:=RealtoInt(Groesse*Lbreite);
        Transform(Endpunkt.X,Endpunkt.Y);
      End;
  End;
  Procedure Changetext;
  Begin
  With Objekt Do
    Begin
      Hoehe:=Groesse*Hoehe;
      Orient:=Phi+Orient;
    End;
  End;
Procedure ChangePfeil;
Begin
  With Objekt Do
  Begin
    Orient:=Phi+Orient;
    Msize:=Msize*Groesse;
  End;
End;
Procedure ChangePeek;
Begin
  With Objekt Do
  Begin
    Orient:=Phi+Orient;
    MP_hoehe:=MP_Hoehe*Groesse;
  End;
End;
Begin
  With Objekt Do
  Begin
    If Macwert.MirMac then
      Spiegle_Obj(Objekt,Yaxis);
    Groesse:=Macwert.Mfac;
    Phi:=Macwert.MPhi;
    Transform(Aufhaenger.X,Aufhaenger.Y);
    Case ElementTyp of
      Auge,
      Achteck,
      Oval      :ChangeAuge;
      Quadrat   :ChangeQuad;
      Kreis,
      M_arc     :ChangeKreis;
      Rechteck  :Change4eck;
      Linie,
      M_line    :ChangeLine;
      Schrift,
      M_text    :ChangeText;
      Masspfeil :ChangePfeil;
      M_peek    :Changepeek;
    End;
  End;
End;

Procedure GetLastKoord;
Var X,Y :Real;
begin
  X:=GrOldX;Y:=GrOldY;
  Retourabbild(X,Y);
  With SetupInfo.Voreinstellung Do
  begin
    LastKoord.X:=
    RealtoInt((X-PlotOffset.X*InvPlotRes)*BackScale)+Ursprung.X;
    LastKoord.Y:=
    RealtoInt((Y-PlotOffset.Y*InvPlotRes)*BackScale)+Ursprung.Y;
 end;
end;

Function Abstand(P1,P2 :Koord):Integer;
{ Manhattan-Distanz }
begin
  Abstand:=Abs(P1.X-P2.X)+Abs(P1.Y-P2.Y);
end;

Function PrepareSearch(Max :Integer):Boolean;
Var I :Integer;
    IsWas :Boolean;
begin
  IsWas:=false;
  For I:=0 to Max Do
    With BildBuff[I] do
      If Status=0 Then
      begin Status:=2; IsWas:=true; end;
      { Status=2 bedeutet :Freigabe zum Zeichnen}
  PrepareSearch:=IsWas;
end;

Function MinSearch(Max :Integer):Integer;
Var I,Dist,Abst,IMin :Integer;
    Temp :Koord;
    Endp :Boolean;
  Procedure Check(Var B :Bildelement);
  begin
    If B.Status=2 Then
        begin
          Abst:=Abstand(B.Aufhaenger,LastKoord);
          If Abst<Dist Then
          begin
            Dist:=Abst;
            Imin:=I;
            Endp:=false;
          end;
          If B.ElementTyp in [Linie,M_line] Then
          begin
            Abst:=Abstand(B.Endpunkt,LastKoord);
            If Abst<Dist Then
              begin
                Dist:=Abst;
                Imin:=I;
                Endp:=true;
              end;
          end;
       end;
  end;
begin
  Dist:=Maxint;
  Imin:=-1;
  Endp:=false;
  GetLastKoord;
  For I:=0 to Max Do Check(BildBuff[I]);
  If Imin>-1 Then
   begin
    With BildBuff[Imin] Do
      If (ElementTyp in [Linie,M_line]) and Endp Then
       begin Temp:=Aufhaenger; Aufhaenger:=Endpunkt; Endpunkt:=Temp; end;
   end;
  MinSearch:=Imin;
end;

Procedure SelectPen(Stift:Integer);
Var E:Integer;
   Done:Boolean;
begin
  E:=0;
  Repeat
    If E in LayersetofPen[Stift]  Then
    begin
      PenColor(EbenenIndex(E));
      Done:=true;
    end;
    E:=Succ(E);
  Until Done or (E>MaxLayer);
end;

Procedure CrunchBuffer(Max :Integer);
Var I,J :Integer;
    Done,
    FoundValid :Boolean;
begin
  I:=0;
  Done:=false;
  Repeat
    With BildBuff[I] do
      If Status=1 then
        begin
          FoundValid:=false;
          J:=I;
          While (J<Max) and Not(Foundvalid) Do
          begin
            Inc(J,1);
            If BildBuff[J].Status<>1 then
              begin
                BildBuff[I]:=BildBuff[J];
                Status:=0;
                BildBuff[J].Status:=1;
                FoundValid:=true;
              end else If J=Max then
                          Done:=true;
          end;
        end else Status:=0;
    Inc(I,1);
  Until (I>Max)  or Done;
  BuffPtr:=0;
  While (BildBuff[BuffPtr].Status<>1) and (BuffPtr<=Max) Do Inc(BuffPtr);
end;

Procedure ZeichneaufBuf(Var Bild :Bildelement;Clearit :Boolean);
Var Clear :Boolean;
    Max,K   :Integer;
    N_Drawn :Integer;
Begin
  Clear:=false;
  If Not(ClearIt) Then
  Begin
    If Buffptr<0 Then Buffptr:=0
    Else
      If Buffptr>MaxBuf Then Buffptr:=MaxBuf;
    UsedLayers:=UsedLayers+[Bild.Ebene];
    If Bild.Ebene in PlotLayers then
     If  Bild.Ebene in LayerSetofPen[Actual_StiftNr]  Then
       Begin
         BildBuff[Buffptr]:=Bild;
         Inc(Buffptr,1);
         Clear:=BuffPtr>MaxBuf;
       End;
    If Clear Then Begin Max:=MaxBuf;Buffptr:=0;End;
    Abbrechen;
  End
  Else
    Begin
      Clear:=true;
      Max:=Buffptr-1;
      Buffptr:=0;
    End;
  If Clear Then
  Begin
    N_Drawn:=0;
    If LayerSetofPen[Actual_StiftNr]<>[] Then
     If PrepareSearch(Max) Then
     begin
      Stiftbreite:=StiftBreiten[Actual_StiftNr];
      Repeat
        K:=MinSearch(Max);
        If K>-1 Then
          Begin
            Inc(Actual_ObjNr,1);
            If (Actual_ObjNr and 7)=0 Then
              begin
                With Plot_win Do
                 DisplayReal(X1+32,Y1+6,PlotHeadCol,Actual_ObjNr,6,0,false);
               end;
            Zeichne(BildBuff[K],DefMacparms);
            BildBuff[K].Status:=1; { bearbeitet }
            Inc(N_Drawn,1);
            If (N_Drawn>MaxBuf div 2) and Not(ClearIt) then
               begin
                 CrunchBuffer(Max);
                 Exit;
               end;
          End;
        Abbrechen;
      Until (K<0) or Not(Weiter) or Not(NoError);
    end;
  End;
End;

Procedure GetMacparms(Var Objekt :Bildelement;Var Parms :Macparms);
Begin
  With Parms Do
  Begin
    XMac:=Objekt.Aufhaenger.X;YMac:=Objekt.Aufhaenger.Y;
    MPhi:=Objekt.Orient;MFac:=Abs(Objekt.Faktor);
    TMac:=true;
    MirMac:=Objekt.Faktor<0;
  End;
End;

Procedure MakePart(M:Bildelement;Var P :Bildelement);
{ erzeugt Part-ID-Element aus Macro }
Type Int =Record
            Lobyte ,
            Hibyte :Byte;
          end;
Var CalcValue :Int;
begin
  Fillchar(P,Sizeof(P),0);
  ClearLibID(M);
  With P Do
  begin
    Ebene:=M.ebene;
    ElementTyp:=Schrift;
    CalcValue.Hibyte:=M.PartX;
    CalcValue.Lobyte:=Byte(M.Ltyp) shl 4;  {X-wert hat Lowbits in Bit 0..3}
    Aufhaenger.X:=Integer(CalcValue) div 4;
    CalcValue.Hibyte:=M.PartY;
    CalcValue.Lobyte:=Byte(M.Ltyp) and $F0;  {Y-wert hat Lowbits in Bit 4..7}
    Aufhaenger.Y:=Integer(CalcValue) div 4;
    Hoehe:=Setupinfo.Voreinstellung.Masshoehe;
    Art:=Setupinfo.EDSetup3.Masstyp;
    Orient:=M.Textorient*5;
    Str(M.PartNr,Wortlaut);
    Wortlaut:=M.PartID+Wortlaut;
  end;
end;

Procedure ZeichneMAC(Var Objekt:Bildelement);
Var Nmax    :Word;
    DatF    :Datafile;
    Obj1    :BildElement;
    Macpar1 :Macparms;
    Listpt  :Maclistptr;
    Foundpt :Macptr;
    Storeit :Boolean;
    MacListName:Str10;
    DummyDate,
    NrOfBLDRecs,
    Offset        :Longint;
    Vers,Count,I  :Word;


Const BildRecHeap=(Sizeof(Maclist) div 8)*8+8;

Begin
  GetMacparms(Objekt,Macpar1);
  If Not PartIDEmpty(Objekt) then { Wegmaskieren LIBID}
  begin
    MakePart(Objekt,Obj1);
    Change(Obj1,Macpar1);
    ZeichneaufBuf(Obj1,false);
  end;
  MacListName:=MacListStr(Objekt);
  If SearchinList(MacListName,Nmax,Foundpt,Listpt) Then
  While (Listpt<>nil) and (Nmax>0) Do
  Begin
    Nmax:=Pred(Nmax);
    With Listpt^ Do
    Begin
      Obj1:=Entry;
      Change(Obj1,Macpar1);
      ZeichneaufBuf(Obj1,false);
      Listpt:=Next;
    End;
  End
  Else
  Begin
    Ok:=LocateMac(Objekt,MacroPath,DataF,DummyDate,Offset,Count);
    If Ok then Openfile(DatF,DataF);
    If Ok Then
     Begin
       If Count=$FFFF then
         NrOfBLDRecs:=UsedRecs(DatF) else NrOfBLDRecs:=Count;
       Storeit:=(Maxavail>1024) and (MemAvail >(NrOfBLDRecs*BildRecHeap+16384));
       If Storeit Then Entertolist(MacListName,Listpt);
       Nmax:=0;
       (*$I-*)
       Seek(DatF,Offset);
       OK:=IoResult=0;
       BlockRead(DatF,Obj1,1);
       OK:=Ok and (IoResult=0);
       Vers:=Defaults(Obj1).GEDVersion;
       FitVersionCode(Vers);
       I:=0;
       While Ok and Not(Eof(DatF)) and (I<Count) do
       Begin
         BlockRead(DatF,Obj1,1);
         Update_Obj(Obj1,Vers);
         Inc(I);
         Ok:=IoResult=0;
         If Ok and (Obj1.Status=0)
            and (Byte(Obj1.Elementtyp)<Byte(ED_CON1))  Then
           Begin
             Nmax:=Succ(Nmax);
             If Storeit Then EntertoMac(Obj1,Listpt);
             Change(Obj1,Macpar1);
             ZeichneaufBuf(Obj1,false);
           End;
       End;
       If Storeit Then Macroslast^.MaxRecs:=Nmax;
       CloseFile(DatF);
       (*$I+*)
     End
  Else
    Begin
      Zeichne(Objekt,DefMacparms);
      If Batch then
      begin
        FullScreen;
        Error(102);
      end;
      If
      SelectError('Macro '+Fullname_O(Objekt)+' nicht gefunden, Abbrechen ? (J/N)',
                  'Fehler:',['J','N',Esc]) ='J' Then
        Weiter:=false
      Else OK:=true;
    End;
  End;
End;

Procedure Title_Line(Y:Integer;S:Str80);
Var C :Byte;
begin
  If ModeCo80 then C:=CalcAttr(Crt.White,Crt.Blue)
    else C:=CalcAttr(Crt.black,Crt.LightGray);
  DisplayString(1,Y,C,Center(S,80));
end;

Procedure HeadLine(S:Str80);
begin
  Title_Line(1,S);
end;

Procedure Line25;
begin
  Title_Line(25,'<Pg-Up>-Fertig             <Cursor-Tasten>-Editieren');
end;


Procedure Escape;
Begin
  ErrorInit;
  Title_Line(25,'****   Esc-Taste --> Abbruch    ****');
  Delay(70*Delfac);
End;

Procedure InitPlotRes(Res:Real);
begin
  If Res<1E-3 then Res:=1E-3;
  PlotRes:=Res;InvPlotRes:=1.0/PlotRes;
end;

Procedure PlotInit;
Begin
 Devicename:='Plotter';
 IgnorePaperout:=true;
 With Setupinfo.SetupPlotter Do
  Begin
    Spiegeln:=false;
    Portrait:=false;
    AufDatei:=Outpath<>'';
    FensterX1:=MinFormX;FensterY1:=MinFormY;
    FensterX2:=FormX;FensterY2:=FormY;
    InitPlotRes(SetupInfo.PinstInfo.Resolution);
    Grafwindow(FensterX1,FensterY1,FensterX2,FensterY2);
    Turnto(0);
    PlotModus:=Standard;
    PlotSpeed:=Pspeed;
    HauptF:=FileSetup.DWG;
    LoetStopPlus:=0.0;
    Buffptr:=0;
    PlotModus:=Standard;
    StiftBreite:=0.1; { 0.1 mm = 0.1}
    PlotScale:=1.0;
    PlotOffset.X:=MinFormX;
    PlotOffset.Y:=MinFormY;
  end;
  With SetupInfo.PinstInfo Do
  begin
    Emul_LT:= (LtFullCom='') or (LtdashCom='') or (LTdotCom='');
           { Erzwingt Software-Emulation gestrichelter Linien !!! }
    If Emul_LT then LineScaleFac:=1.0;
    Lscaledashed:=5.0;
    Lscaledotted:=7.5;
    Endsym:=TermStr;
    ComInstalled:=(DrawCom<>'') and (MoveCom<>'');
  end;
  AdaptLines:=true;
End;

PROCEDURE Crea_men;
  TYPE txtarr    = ARRAY [1 .. 15] OF Str80;
  VAR  texte: txtarr;
       P,Lw,L :Byte;
       DWGing :Str64;
  BEGIN
    texte[1] := ' E~i~nstellungen';
    texte[2] := ' ~E~benen';
    texte[3] := ' Stift~b~reiten ';
    texte[4] := ' Plot~m~odus : ';
    texte[5] := ' ~P~lotten';
    texte[6] := ' FORMAT ~l~aden ';
    texte[7] := ' FORMAT ~s~peichern ';
    texte[8] := ' Format l~ö~schen ';
    P:=8;
    With FileSetUp Do
    begin
      DWGing:=DWG;
      ProcessFilename(DWGpath,DWGing);
      Lw:=Length(DWGing);
      L:=Length(LIBpath);
      IF Lw<L Then Lw:=L;
      Lw:=Lw+4;
      If Lw<28 then Lw:=28;
      MakeMenue(men_main,5,8,Lw,P+8,P,MainWinCol,MainFlpCol,MainHiCol,
                Ptr(Seg(texte),Ofs(texte)),wok);
      WriteToWindow(men_main.picture,7,1,MainHeadCol,' Plot-Menü ');
      WriteToWindow(men_main.picture,1,P+2,MainWinCol,
                      '└'+ConstStr('─',Lw-2)+'┘');
      WriteToWindow(men_main.picture,3,P+2,MainHeadCol,
                    ' '+Chr(24)+Chr(25)+' wählen   <ESC> Ende ');
      WriteToWindow(men_main.picture,1,P+3,MainWinCol,
                      '┌'+ConstStr('─',Lw-2)+'┐');

      WriteToWindow(men_main.picture,3,P+4,MainNorCol,'Zeichnung :');
      WriteToWindow(men_main.picture,3,P+5,CopyWrCol,DWGing);
      WriteToWindow(men_main.picture,3,P+6,MainNorCol,'Bibliothek :');
      WriteToWindow(men_main.picture,3,P+7,MainLowCol,LIBpath);
    end;
    texte[1] := ' ~S~tandard-Plot';
    texte[2] := ' ~L~ötstopmaske';
    texte[3] := ' ~B~estückungsplan';
    texte[4] := ' ~T~est-Plot';
    P:=4;
    MakeMenue(men_Mode,10,12,30,P+2,P,ModeWinCol,ModeFlpCol,ModeHiCol,
          Ptr(Seg(texte),Ofs(texte)),wok);
    WriteToWindow(men_Mode.picture,7,1,ModeHeadCol,' PLOT-MODUS ');
    WriteToWindow(men_Mode.picture,3,P+2,ModeHeadCol,
                  ' '+Chr(24)+Chr(25)+' wählen   <ESC> Ende ');
  END;  (*  Crea_men  *)